home *** CD-ROM | disk | FTP | other *** search
/ The Best of MacTutor - S…e Code for Volumes 1 to 5 / The Best of MacTutor - Source Code for Volume 1-5 (Wayzata Technology)(6031)(1990).bin / Source Code / #41 (Feb 89) / Forth code / Structures 2.5 < prev   
Text File  |  1988-12-15  |  15KB  |  561 lines
  1. ( STRUCTUREs 2.5   for the Macintosh  MACH2 version 2.1 )
  2. ( Jan 3, 1987 by Waymen Askey )
  3. ( This MACH2 extension is released for the public good; however,
  4.   for those planning commercial use of this code, please notify 
  5.   me so that I might know of its intended use.
  6.   
  7.               Waymen Askey
  8.               P.O. Box 901
  9.               Vista, Ca 92083
  10.   also 
  11.   GEnie MACH2 RoundTable.)
  12.  
  13. \ floating point parameters and arrays added by 
  14. \ J. Langowski @ MacTutor
  15.  
  16. only mac also sane also forth definitions
  17.  
  18. ( VARIABLES used in STRUCTURE 2.5 )
  19. decimal
  20. variable current.template
  21. variable op.type
  22. variable A5offset ( holds the A5 offset to a structure )
  23.  
  24. ( CODE word utilities used in STRUCTURE 2.5 )
  25. code var.link  ( -- a | variable link pointer )
  26.     lea $F7F8(A5),A0
  27.      move.l A0,-(A6)
  28.      rts
  29. end-code
  30.  
  31. code a5@  ( -- a )
  32.     move.l A5,-(A6)
  33.      rts
  34. end-code mach
  35.   
  36. code get.field  ( a1 a2 -- a3 -1 or 0 | searches templates )
  37.   ( a1=template, a2= pad, a3=field pointer, 0 if not found )
  38.     move.l (A6)+,D2
  39.     move.l (A6)+,D3
  40.      moveq.l #0,D1
  41.      moveq.l #0,D0
  42. @start  movea.l D3,A1
  43.         movea.l D2,A0
  44.         move.b (A1)+,D1  ( link to next field )
  45.         beq.s @end       ( if link=0, field not found )
  46.         move.b (A1),D0
  47. @loop   cmpm.b (A1)+,(A0)+
  48.         dbne D0,@loop
  49.         beq.s @found
  50.         add.l D1,D3   ( increment field pointer )
  51.         bra.s @start
  52. @found  movea.l D3,A1
  53.         move.b 1(A1),D1  ( get string count )
  54.         addq.w #2,D1
  55.         btst #0,D1  ( test for odd count )
  56.         beq.s @even
  57.         addq.w #1,D1
  58. @even   add.l D1,D3
  59.         moveq.l #-1,D1
  60.         move.l D3,-(A6)
  61. @end    move.l D1,-(A6)
  62.         rts
  63. end-code
  64.  
  65. code >sr  ( n -- | push value onto subroutine stack )
  66.     move.l (A6)+,-(A7)
  67.      rts
  68. end-code mach
  69.  
  70. code sr>  ( -- n | pop value from subroutine stack )
  71.     move.l (A7)+,-(A6)
  72.      rts
  73. end-code mach
  74.  
  75. code sr@  ( -- n | copy value from subroutine stack )
  76.     move.l (A7),-(A6)
  77.      rts
  78. end-code mach
  79.  
  80. ( Miscellaneous utility words used in STRUCTURE 2.5 )
  81. : >even  ( a -- a' | word aligns address, i.e. rounds up to even)
  82.     dup  1 and  + ;
  83.  
  84. : >odd  ( a -- a' | odd aligns address, rounds up to odd )
  85.     1 or ;
  86.  
  87. : needed  ( n -- | checks for at least n items on stack )
  88.     depth 1- > abort" Missing needed stack item(s)! " ;
  89.  
  90. ( Brute-force machine code words )
  91. : ncode,  
  92. ( n1...n -- | machine code defining word, stuffs n words )
  93.     create   dup needed   dup 2* w,   
  94.      0 do   w,   loop
  95.      does>   ( -- | compiles machine code )
  96.          dup   2+ swap   dup w@   +   
  97.         do   i  w@  w,   -2 +loop ;  
  98.  
  99. hex
  100. ( define some machine code "stuff" words )
  101. 41ED 1 ncode,  lea_d(a5),a0      
  102. 4EBA 1 ncode, jsr_d(PC)
  103. 4EAD 1 ncode, jsr_d(A5)
  104. ( LEA and JSR also need a word of extension for displacement )
  105. 2D3C 1 ncode, move.l_#,-(A6)  ( plus a long extension for # )
  106. 2D08 1 ncode,  move.l_a0,-(a6)     
  107. 4E75 1 ncode,  rts,
  108. ( The following expect an address to be in A0 )
  109. 7000 1010 2D00 3 ncode, byte@
  110. 7000 3010 2D00 3 ncode, word@
  111. 2D10 1 ncode, long@
  112. 201E 1080 2 ncode, byte!
  113. 201E 3080 2 ncode, word!
  114. 209E 1 ncode, long!
  115. 5187 5587 2247 22d8 22d8 32d8 6 ncode, real@
  116. 2247 20d9 20d9 30d9 5087 5487 6 ncode, real!
  117. 201e e580 2d30 0000 4 ncode, array@
  118. 201e e580 219e 0000 4 ncode, array!
  119. 201e e380 4281 3230 0000 2d01 6 ncode, warray@
  120. 201e e380 221e 3181 0000 5 ncode, warray!
  121. decimal
  122.  
  123. ( Dictionary header, name, and struct link words )
  124. : link>name   ( lfa -- 'nf | 'nf points to the header length byte)
  125.     4 + ;
  126.     
  127. : name.count   ( 'nf -- 'nf+1  n | dictionary header name count)
  128.     count 31 and ;
  129.  
  130. : link>segment  ( lfa -- 'sf | 'sf is the dictionary segment field address)
  131.     link>name name.count  +  >even ;
  132.     
  133. : link>parameter  ( lfa -- 'pf | 'pf is the parameter field pointer)
  134.     link>segment 2+ ;
  135.  
  136. : link>struct  ( lfa -- struct.fields )
  137.     link>segment 4 + ;
  138.  
  139. : jsr_d(PC),  ( lfa -- | compiles PC relative JSR)
  140.     jsr_d(PC)
  141.     link>body here -  w, ;
  142.     
  143. : jsr_d(A5),  ( lfa -- | compiles A5 relative JSR, i.e. jump table )
  144.     jsr_d(A5)  
  145.     link>parameter w@  w, ;
  146.  
  147. : struct.zero  ( -- lfa | returns lfa of struct.zero )
  148.     " struct.zero" find  drop ;
  149.  
  150. : nallot  ( n -- | allots n bytes in name space )
  151.     np +! ; 
  152.   
  153. : name,   ( -- parses and compiles text into name space.)
  154.     32 word  np @  over c@ 1+  dup >odd nallot  cmove ;
  155.  
  156. : nc,  ( n -- | compiles byte into name space )
  157.     np @ c!   1 nallot ;
  158.  
  159. : nw,  ( n -- | compiles word into name space )
  160.     np @ w!   2 nallot ;
  161.  
  162. : n,  ( n -- | compiles long into name space )
  163.     np @ !   4 nallot ;
  164.  
  165. ( TEMPLATE, STRUCTURE and field words )
  166. : struct.error  ( -- )
  167.   cr pad count type 
  168.   ."  ?  Error, unknown field or incomplete structure path! "
  169.   abort ;
  170.   
  171. global 
  172. : template  ( -- here 0 | begins TEMPLATE definition )   
  173.   create here 0   2 allot 
  174.   does>  ( -- template.size ) 
  175.     dup w@ swap 4 - body>link   current.template ! ;
  176.     
  177. : tend  ( here n -- | (T)emplate(END) ends template definition  )
  178.   swap w!   0 nw, ;
  179.   
  180. global 
  181. : afield  ( size op.type --  )
  182.   create  w,  >even w,
  183.   does>  ( here Toffset -- here new.Toffset )
  184.          ( Toffset means (T)emplate(OFFSET) )  
  185.     2dup 2+   w@  + >sr  
  186.     w@  np @ >sr  1 nallot  name,  
  187.     0 nc, ( field type=0 )   nc, ( op.type )   
  188.     nw, ( Toffset )   np @ sr@ - sr> c! ( field link )
  189.     sr> ;
  190.      
  191. ( The following op.types are reserved and defined below )
  192. ( 06 byte, 12 word, 18 long, 24 string, 30 real, 36 struct, 
  193. 42 array, 48 warray )
  194.  
  195. ( size.in.bytes op.type  AFIELD  named.afield.type )
  196. 1     06 afield  :byte   
  197. 2     12 afield  :word
  198. 4     18 afield  :long
  199. 10     30 afield  :real
  200.  
  201. : :string  ( here Toffset size -- here Toffset+size+1  )
  202.     3 needed  1+   over +   >even swap   np @ >sr  1 nallot  name,   
  203.     0 nc, ( field type=0 )   24 nc, ( op.type=24) 
  204.   nw, ( Toffset )   np @ sr@ - sr> c! ( field link ) ;     
  205.  
  206. : :array  ( here Toffset size -- here Toffset+size+1  )
  207.     3 needed  4* over +   swap   np @ >sr  1 nallot  name,   
  208.     0 nc, ( field type=0 )   42 nc, ( op.type=42) 
  209.   nw, ( Toffset )   np @ sr@ - sr> c! ( field link ) ;     
  210.  
  211. : :warray  ( here Toffset size -- here Toffset+size+1  )
  212.     3 needed  2* over +   swap   np @ >sr  1 nallot  name,   
  213.     0 nc, ( field type=0 )   48 nc, ( op.type=48) 
  214.   nw, ( Toffset )   np @ sr@ - sr> c! ( field link ) ;     
  215.  
  216. : :struct  ( here Toffset size -- here Toffset+size  )
  217.     3 needed  over +   >even swap   np @ >sr  1 nallot  name,  
  218.     06 nc, ( field type=06 )  36 nc, ( op.type=36 )
  219.   nw, ( Toffset )
  220.     current.template @  struct.zero - n, ( template link )  
  221.   np @ sr@ - sr> c! ( field link ) ;  
  222.  
  223. : >pad  ( a -- | moves string to pad )
  224.   pad over c@ 1+  cmove ;
  225.  
  226. : make.var.link  { | name.pointer var.pointer vlink --  }
  227.     np @ -> name.pointer  var.link @ -> var.pointer   
  228.     name.pointer var.link ! 
  229.      name.pointer var.pointer -    -> vlink
  230.      name.pointer dup 1 and + -> name.pointer
  231.      vlink name.pointer !
  232.     name.pointer 4 + np ! ;
  233.  
  234. ( Decision table for field type decode )
  235. : do.afield ( ^field.type --  true )
  236.     1+ dup c@ op.type !   1+ w@ A5offset +!   -1 ;
  237.  
  238. : do.bfield  ( ^field.type -- new.template false )
  239.     dup 1+ dup c@ op.type !   1+ w@ A5offset +!
  240.      4 + @   struct.zero +   link>struct   0 ; 
  241.  
  242. : rts rts, ; immediate
  243.  
  244. ( DO.FIELD table entries decode field data )
  245. ( afield's are simple :BYTE, :WORD, :LONG, :STRING types )
  246. ( bfield's are :STRUCT fields )
  247.  
  248. create do.field  ( field_type  table_offset/type )
  249. ]    do.afield rts  (   afield         0            )
  250.     do.bfield rts  (   bfield         6            )
  251. [                ( end of current table          )
  252.  
  253. global
  254. : make.struct  (  template.link A5offset  -- )   
  255. ( This is the word which must resolve a structure reference. )
  256.   A5offset !  ( A5 displacement for the struct )
  257.   36 op.type !  ( set default op.type to struct )
  258.   struct.zero +  link>struct  ( template.address -- )
  259.   begin    
  260.     32 word   >pad
  261.     pad get.field        
  262.     if  ( field found )
  263.       dup  c@ do.field +  execute
  264.     else ( field not found )
  265.       pad find 1 = 
  266.       if 
  267.         link>body   execute  -1
  268.       else 
  269.         struct.error
  270.       then 
  271.     then  
  272.   until ;
  273.  
  274. hex
  275. : structure  
  276. ( n -- | creates structure alloting n bytes in variable space )
  277.   1 needed create   immediate make.var.link   
  278.   -4 allot lea_d(a5),a0  vp @ w,  ( variable-like beginning )
  279.   move.l_#,-(A6)  current.template @ struct.zero - ,    
  280.   move.l_#,-(A6)   vp @ ,  
  281.   " make.struct" find drop dup link>segment  w@ 0=
  282.   if  jsr_d(PC),  else  jsr_d(A5), then
  283.   rts,   
  284.   vallot ; 
  285. decimal
  286.  
  287. ( STRUCTURE operators )
  288. : compileA5  ( -- | compiles A5 reference )
  289.   lea_d(a5),a0  a5offset @ w, ;
  290.  
  291. : pushA5  ( -- | executes A5 var reference )
  292.   a5offset @ a5@ + ;
  293.  
  294. : do.bit  ( -- )  ( I'm lazy, define your own.  W. Askey )
  295.   cr ." BIT operations are yet undefined!" abort ;
  296.  
  297. : do.struct  ( -- )  ( Fetch/store doesn't make sense here. )   
  298.   cr ." STRUCTURE fetch/store operations are undefined! " abort ;
  299.   
  300. : do.string  ( -- )  ( If you wish, define your own. )
  301.   cr ." STRING fetch/store operations are undefined! " abort ;
  302.   
  303. : do.byte@  ( f -- )
  304.   if
  305.     compileA5  byte@
  306.      else
  307.     pushA5 c@
  308.      then ;
  309.  
  310. : do.word@  ( f -- )
  311.   if
  312.     compileA5  word@
  313.   else
  314.     pushA5 w@
  315.   then ;
  316.   
  317. : do.long@  ( f -- )
  318.   if
  319.     compileA5 long@
  320.   else
  321.     pushA5 @
  322.     then ;
  323.  
  324. : do.array@  ( idx f -- )
  325.   if
  326.     compileA5 array@
  327.   else
  328.     4* pushA5 + @
  329.     then ;
  330.  
  331. : do.warray@  ( idx f -- )
  332.   if
  333.     compileA5 warray@
  334.   else
  335.     2* pushA5 + w@
  336.     then ;
  337.  
  338. : do.real@  ( f -- )
  339.   if
  340.     compileA5 real@
  341.   else
  342.     pushA5 f@
  343.     then ;
  344.  
  345.  ( Decision table for fetch )
  346.  create op.table@   ( op.types are offsets into this table ) 
  347.  ]  do.bit rts      ( op.type = 0  )
  348.     do.byte@ rts    (  "  "   = 6  )
  349.     do.word@ rts    (  "  "   = 12 )
  350.     do.long@ rts    (  "   "  = 18  etc, etc. )
  351.     do.string rts
  352.     do.real@ rts
  353.     do.struct rts
  354.     do.array@ rts
  355.     do.warray@ rts
  356. [
  357.  
  358. : do.byte!  ( f -- )
  359.   if
  360.     compileA5  byte!
  361.      else
  362.     pushA5 c!
  363.      then ;
  364.  
  365. : do.word!  ( f -- )
  366.   if
  367.     compileA5  word!
  368.   else
  369.     pushA5 w!
  370.   then ;
  371.   
  372. : do.long!  ( f -- )
  373.   if
  374.     compileA5 long!
  375.   else
  376.     pushA5 !
  377.     then ;
  378.  
  379. : do.array!  ( idx f -- )
  380.   if
  381.     compileA5 array!
  382.   else
  383.     4* pushA5 + !
  384.     then ;
  385.  
  386. : do.warray!  ( idx f -- )
  387.   if
  388.     compileA5 warray!
  389.   else
  390.     2* pushA5 + w!
  391.     then ;
  392.  
  393. : do.real!  ( f -- )
  394.   if
  395.     compileA5 real!
  396.   else
  397.     pushA5 f!
  398.     then ;
  399.  
  400. create op.table!  ( decision table for store )
  401. ]    do.bit rts
  402.     do.byte! rts
  403.     do.word! rts
  404.     do.long! rts
  405.     do.string rts
  406.     do.real! rts
  407.     do.struct rts
  408.     do.array! rts
  409.     do.warray! rts
  410. [
  411.   
  412. : s^  ( -- a | returns pointer to structure field )
  413. ( ALL field types are allowed. i.e. strings, struct, etc. )
  414.     state @ 
  415.     if 
  416.     compileA5 move.l_a0,-(a6)
  417.     else
  418.     pushA5 
  419.     then ; immediate
  420.  
  421. : s@  ( -- data | Fetch field contents, data type smart)
  422.   state @
  423.   op.type @ op.table@ + execute ; immediate
  424.  
  425. : s!  ( data -- | Store into field, data type smart)
  426.   state @
  427.   op.type @ op.table! + execute ; immediate
  428.  
  429. : stype  ( -- op.type | returns the op.type of a field )
  430.     op.type @  state @ 
  431.   if
  432.     [compile] literal
  433.     then ; immediate
  434.  
  435.  
  436. ( Examples of structure usage.  Data Storage is limited to
  437.   the approximately 32K global area referenced off of 
  438.   register A5 -- just as for regular MACH2 variables.
  439.   Structure references have a REQUIRED syntax, it is best 
  440.   NOT to use any non-STRUCTURE Forth words when between field
  441.   names in a structure calling sequence.  That is, please end 
  442.   each structure reference prior to any DUP's, SWAP's, etc. 
  443.   The structure pointer operator -- S^ -- may be used at any
  444.   place in the structure calling sequence.  S^ will return the
  445.   address of the field or structure itself.  Structures MUST
  446.   be terminated with a defined structure operator!  The defined
  447.   operators in this upload are S^, S@, S!, and STYPE.  
  448.   WARNING, if you forget to terminate a structure, no
  449.   structure reference will be compiled and an error message MAY 
  450.   NOT be given.  Remember also that field names ARE CASE
  451.   SENSITIVE and LOCAL to the structure template.  Last comment, 
  452.   structures MAY be nested to any level. ) 
  453.  
  454. fp
  455.  
  456. template Point
  457.     :word x
  458.     :word y
  459. tend
  460.  
  461. template Rect
  462.   :word top
  463.   :word left
  464.   :word bottom
  465.   :word right
  466. tend  ( TEND ends template definition )
  467.   
  468. \ example for FP parameters 
  469. template parameter
  470. 30    :string name
  471.     :real value
  472. 30    :string unit
  473. tend
  474.  
  475. template measurement
  476.     :long date \ in internal Mac format
  477. 80    :string title
  478. 255 :string descriptor
  479. parameter    :struct wavelength
  480. parameter    :struct temperature
  481. parameter    :struct angle
  482. 256    :array    time
  483. 256    :array    counts
  484. tend
  485.  
  486. measurement structure curve1
  487.  
  488. : testarray
  489.     100 0 do i 4* i curve1 time s! loop
  490.     100 0 do i curve1 time s@ . cr loop
  491. ;
  492.  
  493. : .date ( DateTime DateForm ) { | [ 40 lallot ] mydate -- }
  494.     8 shift ^ mydate call IUDateString ^ mydate count type
  495. ;
  496.  
  497. : read.int
  498.     begin
  499.     pad 1+ 80 expect span @ pad c! pad number? not while
  500.     drop cr ." Illegal number [integer], reenter - "
  501.     repeat
  502. ;
  503.  
  504. : read.float
  505.     begin
  506.     pad 1+ 80 expect span @ pad c! pad fnumber? not while
  507.     fdrop cr ." Illegal number [float], reenter - "
  508.     repeat
  509. ;
  510.  
  511. : setup.curve1 { | dattim -- }
  512.     ^ dattim call readdatetime drop @
  513.     cr ." Today is " 1 .date
  514.     cr ." Setting up parameters for curve 1."
  515.     dattim curve1 date s!
  516.     " lambda" dup c@ 1+ curve1 wavelength name s^ swap cmove 
  517.     "      T" dup c@ 1+ curve1 temperature name s^ swap cmove 
  518.     "  delta" dup c@ 1+ curve1 angle name s^ swap cmove 
  519.     " [nm]" dup c@ 1+ curve1 wavelength unit s^ swap cmove 
  520.     "  [K]" dup c@ 1+ curve1 temperature unit s^ swap cmove 
  521.     "  [°]" dup c@ 1+ curve1 angle unit s^ swap cmove 
  522.     cr ." Title (one line) - " cr pad 80 expect
  523.         span @ curve1 title s^ c!
  524.         pad curve1 title s^ 1+ span @ cmove 
  525.     cr ." Description (one line) - " cr pad 80 expect
  526.         span @ curve1 descriptor s^ c!
  527.         pad curve1 descriptor s^ 1+ span @ cmove
  528.     cr ." lambda [nm] - " read.float curve1 wavelength value s!
  529.     cr ."      T  [K] - " read.float curve1 temperature value s!
  530.     cr ."  delta  [°] - " read.float curve1 angle value s!
  531. \ example setup of 'measurement data'
  532.     20 0 do
  533.         i i curve1 time s!
  534.         i 100 * i curve1 counts s!
  535.     loop
  536.  
  537.     cr ." End setup --- " cr
  538. ;
  539.  
  540.   
  541. : dump.curve1 { | [ 80 lallot ] mydate -- }
  542.     cr ." Data taken on " curve1 date s@ 1 .date
  543.     cr curve1 title s^ count type
  544.     cr curve1 descriptor s^ count type
  545.     cr curve1 wavelength name s^ count type ." = "
  546.         curve1 wavelength value s@ f.
  547.         curve1 wavelength unit s^ count type
  548.     cr curve1 temperature name s^ count type ." = "
  549.         curve1 temperature value s@ f.
  550.         curve1 temperature unit s^ count type
  551.     cr curve1 angle name s^ count type ." = "
  552.         curve1 angle value s@ f.
  553.         curve1 angle unit s^ count type
  554.     cr ." data follows:"
  555.     20 0 do cr
  556.         i curve1 time s@ . space
  557.         i curve1 counts s@ .
  558.     loop
  559.     cr
  560. ;
  561.